home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / win / pascal / frameoh.exe / FRAMEDLG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-02-12  |  11.0 KB  |  396 lines
  1.  
  2. {$A+}   { Align data }
  3. {$B-}   { Boolean evaluation }
  4. {$E+}   { 80x87 emulator }
  5. {$F-}   { Force FAR calls }
  6. {$G+}   { 80286 code }
  7. {$I-}   { I/O checking }
  8. {$K-}   { Smart Callbacks }
  9. {$N-}   { 80x87 code }
  10. {$O-}   { Overlays allowed }
  11. {$P-}   { Open parameters }
  12. {$T-}   { Typed pointers }
  13. {$V-}   { String VAR checking }
  14. {$W-}   { Windows stack frame for real mode }
  15. {$X+}   { Extended syntax }
  16.  
  17. {$IFDEF DEBUG}
  18.     {$D+}   { Debug information }
  19.     {$L+}   { Local symbols }
  20.     {$Q+}   { Overflow checking }
  21.     {$R+}   { Range checking }
  22.     {$S+}   { Stack checking }
  23.     {$Y+}   { Symbol reference information }
  24. {$ELSE}
  25.     {$D-}   { Debug information }
  26.     {$L-}   { Local symbols }
  27.     {$Q-}   { Overflow checking }
  28.     {$R-}   { Range checking }
  29.     {$S-}   { Stack checking }
  30.     {$Y-}   { Symbol reference information }
  31. {$ENDIF}
  32.  
  33. {$C Moveable Demandload Discardable} { Code Segment attributes }
  34.  
  35. UNIT FrameDlg;
  36.  
  37. {
  38.   Copyright (c) 1992 by Olaf He▀ (Hess), Munich, Germany.
  39.  
  40.   Please feel free to use this code in your own programs.
  41.   If you make $$$ with it ->> You have my ID!
  42.   If you find any bugs or do any changes to the source code that you find
  43.   generally useful please send me a message to my CompuServe account
  44.   100 031, 35 36.
  45.  
  46.   Thanks.
  47. }
  48.  
  49. {$R FRAMEDLG.RES}
  50.  
  51. INTERFACE
  52.  
  53. USES WinProcs, WinTypes, OWindows, ODialogs;
  54.  
  55. CONST
  56.     rgbLightGray = $C0C0C0; { Light gray }
  57.  
  58. TYPE
  59.     PFrameStatic = ^TFrameStatic;
  60.     TFrameStatic = OBJECT (TStatic)
  61.       PRIVATE
  62.         PROCEDURE WMPaint (VAR Msg: TMessage); VIRTUAL wm_First + wm_Paint;
  63.         PROCEDURE PaintFrame; VIRTUAL;
  64.     END; { TFrameStatic }
  65.  
  66.  
  67.     PStaticUp = ^TStaticUp;
  68.     TStaticUp = OBJECT (TFrameStatic)
  69.         PROCEDURE SetupWindow; VIRTUAL;
  70.         PROCEDURE PaintFrame; VIRTUAL;
  71.     END; { TStaticUp }
  72.  
  73.  
  74.     PStaticDown = ^TStaticDown;
  75.     TStaticDown = OBJECT (TFrameStatic)
  76.         PROCEDURE SetupWindow; VIRTUAL;
  77.         PROCEDURE PaintFrame; VIRTUAL;
  78.     END; { TStaticDown }
  79.  
  80.     PFrameDown = ^TFrameDown;
  81.     TFrameDown = OBJECT (TStaticDown)
  82.         CONSTRUCTOR InitResource (AParent: PWindowsObject;
  83.                                   ResourceId: Integer);
  84.         PROCEDURE SetupWindow; VIRTUAL;
  85.     END; { TFrameDown }
  86.  
  87.     PFrameUp = ^TFrameUp;
  88.     TFrameUp = OBJECT (TStaticUp)
  89.         CONSTRUCTOR InitResource (AParent: PWindowsObject;
  90.                                   ResourceId: Integer);
  91.         PROCEDURE SetupWindow; VIRTUAL;
  92.     END; { TFrameUp }
  93.  
  94.     PSteelDlgWnd = ^TSteelDlgWnd;
  95.     TSteelDlgWnd = OBJECT (TDlgWindow)
  96.         PROCEDURE WMCtlColor (VAR Msg: TMessage);
  97.             VIRTUAL wm_First + wm_CtlColor;
  98.     END; { TSteelDlgWnd }
  99.  
  100.     PSteelDialog = ^TSteelDialog;
  101.     TSteelDialog = OBJECT (TDialog)
  102.         PROCEDURE WMCtlColor (VAR Msg: TMessage);
  103.             VIRTUAL wm_First + wm_CtlColor;
  104.     END; { TSteelDialog }
  105.  
  106.  
  107. VAR
  108.     hBackgroundBrush : hBrush; { Background brush }
  109.     fDoColors : Boolean; { TRUE if graphics card support more than 8 colors }
  110.  
  111. IMPLEMENTATION
  112.  
  113. VAR
  114.     OldExitProc : Pointer;
  115.  
  116. (* ---- *)
  117.  
  118. PROCEDURE TFrameStatic.WMPaint (VAR Msg: TMessage);
  119. { Paint the static control }
  120.  
  121. BEGIN
  122.     INHERITED WMPaint (Msg); { Call ancestor }
  123.     PaintFrame; { Paint borders }
  124. END; { TFrameStatic.WMPaint }
  125.  
  126. (* ---- *)
  127.  
  128. PROCEDURE TFrameStatic.PaintFrame;
  129. { Just a placeholder }
  130.  
  131. BEGIN
  132. END; { TFrameStatic.PaintFrame }
  133.  
  134. (* ---- *)
  135.  
  136. PROCEDURE TStaticUp.SetupWindow;
  137. { Set the window style attributes }
  138.  
  139. VAR
  140.     lStyle : LongInt;
  141.  
  142. BEGIN
  143.     INHERITED SetupWindow; { Call ancestor }
  144.  
  145.     { Get and set the style bits }
  146.     lStyle := GetWindowLong (hWindow, gwl_Style);
  147.     lStyle := lStyle AND NOT ws_Border;
  148.     SetWindowLong (hWindow, gwl_Style, lStyle);
  149. END; { TStaticUp.SetupWindow }
  150.  
  151. (* ---- *)
  152.  
  153. PROCEDURE TStaticUp.PaintFrame;
  154. { Paint a raised border }
  155.  
  156. VAR
  157.     hWindowDC : hDC;
  158.     hOldBrush : hBrush;
  159.     rc : TRect;
  160.     x, y : Integer;
  161.  
  162. BEGIN
  163.     GetClientRect (hWindow, rc); { Get size }
  164.     { Coordinates of the lower right corner }
  165.     x := rc.Right;
  166.     y := rc.Bottom;
  167.     hWindowDC := GetDC (hWindow);
  168.  
  169.     IF (NOT fDoColors) THEN
  170.     BEGIN { Not enough colors ->> paint in black }
  171.         hOldBrush := SelectObject (hWindowDC, GetStockObject (BLACK_BRUSH));
  172.         PatBlt (hWindowDC, 0, 0, x, 1, PATCOPY); { Top line }
  173.         PatBlt (hWindowDC, 0, 0, 1, y, PATCOPY); { Left line }
  174.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Bottom line }
  175.         PatBlt (hWindowDC, x - 1, 1, 1, y - 1, PATCOPY); { Right line }
  176.     END { if }
  177.     ELSE
  178.     BEGIN
  179.         { Color of the top and left line is white }
  180.         hOldBrush := SelectObject (hWindowDC,
  181.                                    GetStockObject (WHITE_BRUSH));
  182.  
  183.         PatBlt (hWindowDC, -1, -1, x + 2, 2, PATCOPY); { Paint top line }
  184.         PatBlt (hWindowDC, -1, 1, 2, y, PATCOPY); { Paint left line }
  185.  
  186.         { Color of the bottom and right line is gray }
  187.         SelectObject (hWindowDC, GetStockObject (GRAY_BRUSH));
  188.  
  189.         { Paint bottom line }
  190.         PatBlt (hWindowDC, 1, y - 1, x, 1, PATCOPY); { Inside }
  191.         PatBlt (hWindowDC, 0, y, x + 1, 1, PATCOPY); { Middle }
  192.         PatBlt (hWindowDC, -1, y + 1, x + 2, 1, PATCOPY); { Outside }
  193.  
  194.         { Paint right line }
  195.         PatBlt (hWindowDC, x - 2, 1, 1, y - 2, PATCOPY); { Inside }
  196.         PatBlt (hWindowDC, x - 1, 0, 1, y - 1, PATCOPY); { Middle }
  197.         PatBlt (hWindowDC, x, -1, 1, y, PATCOPY); { Outside }
  198.     END; { else }
  199.  
  200.     SelectObject (hWindowDC, hOldBrush);
  201.     ReleaseDC (hWindow, hWindowDC);
  202. END; { TStaticUp.PaintFrame }
  203.  
  204. (* ---- *)
  205.  
  206. PROCEDURE TStaticDown.SetupWindow;
  207. { Set the window style attributes }
  208.  
  209. VAR
  210.     lStyle : LongInt;
  211.  
  212. BEGIN
  213.     INHERITED SetupWindow; { Call ancestor }
  214.  
  215.     { Get and set the style bits }
  216.     lStyle := GetWindowLong (hWindow, gwl_Style);
  217.     lStyle := lStyle AND NOT ws_Border;
  218.     SetWindowLong (hWindow, gwl_Style, lStyle);
  219. END; { TStaticDown.SetupWindow }
  220.  
  221. (* ---- *)
  222.  
  223. PROCEDURE TStaticDown.PaintFrame;
  224. { Paint a recessed static control }
  225.  
  226. VAR
  227.     hWindowDC : hDC;
  228.     hOldBrush : hBrush;
  229.     rc : TRect;
  230.     x, y : Integer;
  231.  
  232. BEGIN
  233.     GetClientRect (hWindow, rc); { Get size }
  234.     { Coordinates of the lower right corner }
  235.     x := rc.Right;
  236.     y := rc.Bottom;
  237.     hWindowDC := GetDC (hWindow);
  238.  
  239.     IF (NOT fDoColors) THEN
  240.     BEGIN { Not enough colors ->> paint in black }
  241.         hOldBrush := SelectObject (hWindowDC, GetStockObject (BLACK_BRUSH));
  242.         PatBlt (hWindowDC, 0, 0, x, 1, PATCOPY); { Top line }
  243.         PatBlt (hWindowDC, 0, 0, 1, y, PATCOPY); { Left line }
  244.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Bottom line }
  245.         PatBlt (hWindowDC, x - 1, 1, 1, y - 1, PATCOPY); { Right line }
  246.     END { if }
  247.     ELSE
  248.     BEGIN
  249.         { Color of the top and left line is gray }
  250.         hOldBrush := SelectObject (hWindowDC,
  251.                                    GetStockObject (GRAY_BRUSH));
  252.  
  253.         PatBlt (hWindowDC, -1, -1, x + 1, 3, PATCOPY); { Paint top line }
  254.         PatBlt (hWindowDC, -1, 0, 3, y, PATCOPY); { Paint left line }
  255.  
  256.         { Color of the bottom and right line is white }
  257.         SelectObject (hWindowDC, GetStockObject (WHITE_BRUSH));
  258.  
  259.         { Paint bottom line }
  260.         PatBlt (hWindowDC, 1, y - 1, x - 1, 1, PATCOPY); { Inside }
  261.         PatBlt (hWindowDC, 0, y, x - 1, 1, PATCOPY); { Outside }
  262.  
  263.         { Paint right line }
  264.         PatBlt (hWindowDC, x - 1, 1, 1, y, PATCOPY); { Inside }
  265.         PatBlt (hWindowDC, x, 0, 1, y + 1, PATCOPY); { Outside }
  266.     END; { else }
  267.  
  268.     SelectObject (hWindowDC, hOldBrush);
  269.     ReleaseDC (hWindow, hWindowDC);
  270. END; { TStaticDown.PaintFrame }
  271.  
  272. (* ---- *)
  273.  
  274. CONSTRUCTOR TFrameDown.InitResource (AParent: PWindowsObject;
  275.                                            ResourceId: Integer);
  276.  
  277. BEGIN
  278.     { Call ancestor, set text length to 0 }
  279.     INHERITED InitResource (AParent, ResourceId, 0);
  280. END; { TFrameDown.InitResource }
  281.  
  282. (* ---- *)
  283.  
  284. PROCEDURE TFrameDown.SetupWindow;
  285. { Set the window style attributes }
  286.  
  287. VAR
  288.     lStyle : LongInt;
  289.  
  290. BEGIN
  291.     TFrameStatic.SetupWindow; { Call TFrameStatic directly }
  292.  
  293.     { Set the style bits }
  294.     lStyle := ws_Visible OR ws_Child OR ws_Group OR ss_WhiteRect;
  295.     SetWindowLong (hWindow, gwl_Style, lStyle);
  296. END; { TFrameDown.SetupWindow }
  297.  
  298. (* ---- *)
  299.  
  300. CONSTRUCTOR TFrameUp.InitResource (AParent: PWindowsObject;
  301.                                            ResourceId: Integer);
  302.  
  303. BEGIN
  304.     { Call ancestor, set text length to 0 }
  305.     INHERITED InitResource (AParent, ResourceId, 0);
  306. END; { TFrameUp.InitResource }
  307.  
  308. (* ---- *)
  309.  
  310. PROCEDURE TFrameUp.SetupWindow;
  311. { Set the window style attributes }
  312.  
  313. VAR
  314.     lStyle : LongInt;
  315.  
  316. BEGIN
  317.     TFrameStatic.SetupWindow; { Call TFrameStatic directly }
  318.  
  319.     { Set the style bits }
  320.     lStyle := ws_Visible OR ws_Child OR ws_Group OR ss_WhiteRect;
  321.     SetWindowLong (hWindow, gwl_Style, lStyle);
  322. END; { TFrameUp.SetupWindow }
  323.  
  324. (* ---- *)
  325.  
  326. PROCEDURE TSteelDlgWnd.WMCtlColor (VAR Msg: TMessage);
  327. { Set the background color for the dialog window + it's controls }
  328.  
  329. BEGIN
  330.     DefWndProc (Msg); { Call standard proc first }
  331.     WITH Msg DO
  332.         IF (NOT fDoColors) THEN Exit { Not enough colors }
  333.         ELSE
  334.         BEGIN
  335.             SetBkColor (wParam, rgbLightGray); { Set backround color }
  336.  
  337.             IF (lParamHi = CtlColor_Dlg) THEN
  338.                 { Background brush for dialog window }
  339.                 Result := hBackgroundBrush
  340.             ELSE Result := GetStockObject (LtGray_Brush); { Gray in gray }
  341.         END; { else }
  342. END; { TSteelDlgWnd.WMCtlColor }
  343.  
  344. (* ---- *)
  345.  
  346. PROCEDURE TSteelDialog.WMCtlColor (VAR Msg: TMessage);
  347. { Set the background color for the dialog window + it's controls }
  348.  
  349. BEGIN
  350.     WITH Msg DO
  351.         IF (NOT fDoColors) THEN Exit { Not enough colors }
  352.         ELSE
  353.         BEGIN
  354.             SetBkColor (wParam, rgbLightGray); { Set background color }
  355.  
  356.             IF (lParamHi = CtlColor_Dlg) THEN
  357.                 { Background brush for dialog window }
  358.                 Result := hBackgroundBrush
  359.             ELSE Result := GetStockObject (LtGray_Brush); { Gray in gray }
  360.         END; { else }
  361. END; { TSteelDialog.WMCtlColor }
  362.  
  363. (* ---- *)
  364.  
  365. PROCEDURE NewExitProc; FAR;
  366. { Release background brush }
  367.  
  368. BEGIN
  369.     DeleteObject (hBackGroundBrush); { Delete brush }
  370.  
  371.     { Call old EXIT-proc }
  372.     ExitProc := OldExitProc;
  373. END; { NewExitProc }
  374.  
  375. (* ---- *)
  376.  
  377. VAR
  378.     hBackgroundBitmap : hBitmap;
  379.     hWindowsDC : hDC;
  380.  
  381. BEGIN { FrameDlg }
  382.     { Set new EXIT-proc }
  383.     OldExitProc := ExitProc;
  384.     ExitProc := @NewExitProc;
  385.  
  386.     { Can the graphics card display more than 8 colors }
  387.     hWindowsDC := GetDC (0);
  388.     fDoColors := GetDeviceCaps (hWindowsDC, NumColors) >= 8; { Get colors }
  389.     ReleaseDC (0, hWindowsDC);
  390.  
  391.     { Load new background brush }
  392.     hBackGroundBitmap := LoadBitmap (hInstance, 'MY_BRUSH');
  393.     hBackGroundBrush := CreatePatternBrush (hBackGroundBitmap);
  394.     DeleteObject (hBackGroundBitmap);
  395. END. { FrameDlg }
  396.